Shareware Grab Bag

home *** CD-ROM | disk | FTP | other *** search

/ Shareware Grab Bag / Shareware Grab Bag.iso / 010 / cardgame.arc / KLONDIKE.BAS next >

Wrap

BASIC Source File | 1986-04-16 | 13.2 KB | 366 lines

10 CLS 15 DIM DECK$(52),PRE(52),SUIT$(4),CARD$(13),CLR(4,2),ROW$(7,19,2),NDECK$(52) 20 DIM ACES$(4) 25 DEF FNR(X)=INT((RND*X)+1) 26 RANDOMIZE(VAL(RIGHT$(TIME$,2))) 30 PRINT "Klondike Solitaire":PRINT 31 PRINT "Do you want color? "; 32 A$=INKEY$:IF A$="" THEN 32 33 GOSUB 10000:IF A$<>"Y" AND A$<>"N" THEN 32 ELSE PRINT A$:COL$=A$ 34 PRINT "Do you need Instructions? "; 35 A$=INKEY$:IF A$="" THEN 35 36 GOSUB 10000:IF A$<>"Y" AND A$<>"N" THEN 35 ELSE PRINT A$ 37 IF A$="Y" THEN GOSUB 5000 40 PRINT "Initializing ... " 45 GOSUB 1000 50 PRINT "Shuffling ... " 60 GOSUB 1200 65 PRINT "Dealing ... " 70 GOSUB 1500 80 GOSUB 1700 90 TOP=3 91 COLOR 7,1:LOCATE 15,50:PRINT " C - more cards "; 92 LOCATE 16,50:PRINT " D - move from deck "; 93 LOCATE 17,50:PRINT " Row Number to move from row "; 94 LOCATE 18,50:PRINT " Q to quit ";:COLOR 7,0 100 LOCATE 19,1:PRINT "Next card in deck:"; 110 IF NDECK<1 THEN PRINT "None";:GOTO 140 120 C$=NDECK$(TOP):GOSUB 1300 140 LOCATE 21,1:PRINT USING "Card ## of ## left in deck";TOP;NDECK; 150 LOCATE 23,1:PRINT " "; 152 IF SCORE > 51 THEN 900 155 LOCATE 22,1:PRINT "What do you want to do? ";:LOCATE 22,23 160 A$=INKEY$:IF A$="" THEN 160 ELSE GOSUB 10000 170 IF A$="C" THEN PRINT A$;:GOSUB 300:GOTO 100 180 IF A$="D" THEN PRINT A$;:GOSUB 350:GOTO 100 190 IF A$>="1" AND A$<="7" THEN PRINT A$;:GOSUB 600:GOTO 100 200 IF A$="Q" THEN 900 210 GOTO 160 300 REM Get more cards from deck 310 IF TOP=NDECK THEN TOP=3 ELSE TOP=TOP+3 320 IF TOP>NDECK THEN TOP=NDECK 330 RETURN 350 REM Move from deck to a row 360 LOCATE 23,1:PRINT "From deck to row? "; 380 A$=INKEY$:GOSUB 10000:IF (A$>="1" AND A$<="7") OR A$="A" THEN 390 ELSE 380 390 IF A$="A" THEN PRINT "Aces"; ELSE PRINT A$; 395 IF A$="A" THEN 540 400 TOROW=VAL(A$) 410 FOR PLACE=19 TO 1 STEP -1 420 IF ROW$(TOROW,PLACE,2)<>" " THEN 460 430 NEXT PLACE 432 IF ROW$(TOROW,1,2)=" " AND LEFT$(NDECK$(TOP),2)=" K" THEN PLACE=0:GOTO 500 440 GOSUB 990 450 RETURN 460 BELOW$=ROW$(TOROW,PLACE,2) 470 ABOVE$=NDECK$(TOP) 480 GOSUB 2000 'check if match 490 IF OK$="NO" THEN 440 500 ROW$(TOROW,PLACE+1,1)=NDECK$(TOP) 510 ROW$(TOROW,PLACE+1,2)=NDECK$(TOP) 520 ROW=TOROW:GOSUB 3100 525 GOSUB 2200 'repack deck 530 RETURN 540 REM Play Deck to Aces 550 ABOVE$=NDECK$(TOP) 560 GOSUB 2300 'play to aces 570 IF OK$="NO" THEN 440 580 GOTO 525 600 REM Move from one row to another 610 FROMROW=VAL(A$) 620 FOR FROMPLACE=1 TO 19 630 IF ROW$(FROMROW,FROMPLACE,2)<>DOWN$ THEN 660 640 NEXT FROMPLACE 650 GOSUB 990:RETURN 660 LOCATE 23,1:PRINT "From row";FROMROW;"to row? "; 680 A$=INKEY$:GOSUB 10000:IF (A$>="1" AND A$<="7") OR A$="A" THEN 690 ELSE 680 690 IF A$="A" THEN PRINT "Aces"; ELSE PRINT A$; 695 IF A$="A" THEN 830 700 TOROW=VAL(A$) 710 FOR TOPLACE=19 TO 1 STEP -1 720 IF ROW$(TOROW,TOPLACE,2)<>" " THEN 760 730 NEXT TOPLACE 732 IF ROW$(TOROW,1,2)=" " AND LEFT$(ROW$(FROMROW,FROMPLACE,2),2)=" K" THEN TOPLACE=0:GOTO 800 740 GOSUB 990 750 RETURN 760 REM 770 ABOVE$=ROW$(FROMROW,FROMPLACE,2) 775 BELOW$=ROW$(TOROW,TOPLACE,2) 780 GOSUB 2000 'check if match 790 IF OK$="NO" THEN 740 800 GOSUB 3200 'move the stack 810 ROW=FROMROW:GOSUB 3100 'redraw a row 815 ROW=TOROW:GOSUB 3100 'redraw a row 820 RETURN 830 REM play from a row to aces 832 FOR FROMPLACE=19 TO 1 STEP -1 834 IF ROW$(FROMROW,FROMPLACE,2)<>" " THEN 840 836 NEXT FROMPLACE 838 GOSUB 990:RETURN 840 ABOVE$=ROW$(FROMROW,FROMPLACE,2) 850 GOSUB 2300 'play to aces 851 IF OK$="NO" THEN 740 853 REM ROW$(FROMROW,FROMPLACE,1)=" " 854 ROW$(FROMROW,FROMPLACE,2)=" " 855 IF FROMPLACE>1 THEN ROW$(FROMROW,FROMPLACE-1,2)=ROW$(FROMROW,FROMPLACE-1,1) 856 ROW=FROMROW:GOSUB 3100 'redraw a row 860 RETURN 900 REM Exit game 901 LOCATE 19,1:PRINT " "; 902 LOCATE 21,1:PRINT " "; 903 LOCATE 22,1:PRINT " "; 904 LOCATE 23,1:PRINT " "; 905 LOCATE 24,1:PRINT " "; 910 GOSUB 1800 920 GOSUB 1900 925 FOR I=1 TO 20:A$=INKEY$:NEXT I 930 GOSUB 3400:PRINT "Play again? (Y or N) "; 940 A$=INKEY$:IF A$="" THEN 940 950 GOSUB 10000 960 IF A$="N" THEN 970 961 IF A$="Y" THEN CLS:PRINT "Re-";:GOTO 40 965 GO TO 940 970 CLS:PRINT "Bye":END 990 REM Bad Play 992 COLOR 0,7:LOCATE 23,50:PRINT " Can't do that! "; 994 LOCATE 24,50:PRINT " Press any key to continue ";:COLOR 7,0 996 IF INKEY$="" THEN 996 997 LOCATE 23,50:PRINT " "; 998 LOCATE 24,50:PRINT " "; 999 RETURN 1000 REM 1005 DOWN$=CHR$(178):DOWN$=DOWN$+DOWN$+DOWN$ 1009 IF COL$="N" THEN 1020 1010 FOR I=1 TO 2:CLR(I,1)=4:CLR(I,2)=7:NEXT 1015 FOR I=3 TO 4:CLR(I,1)=0:CLR(I,2)=7:NEXT 1019 GO TO 1030 1020 FOR I=1 TO 2:CLR(I,1)=0:CLR(I,2)=7:NEXT 1025 FOR I=3 TO 4:CLR(I,1)=7:CLR(I,2)=0:NEXT 1030 FOR I=1 TO 4:SUIT$(I)=CHR$(I+2):NEXT I 1035 FOR I=1 TO 4:ACES$(I)=" ":NEXT I 1040 FOR I=2 TO 9:CARD$(I)=STR$(I):NEXT I 1050 CARD$(1)=" A":CARD$(10)="10":CARD$(11)=" J":CARD$(12)=" Q":CARD$(13)=" K" 1060 FOR I=1 TO 4 1070 FOR J=1 TO 13 1080 K=(I-1)*13+J 1090 DECK$(K)=CARD$(J)+SUIT$(I) 1100 NEXT J 1110 NEXT I 1120 FOR I=1 TO 7 1130 FOR J=1 TO 19 1140 ROW$(I,J,1)=" ":ROW$(I,J,2)=" " 1150 NEXT J,I 1160 SCORE=0 1170 RETURN 1200 REM Shuffle 1210 FOR I=1 TO 52:NDECK$(I)="":NEXT I 1220 FOR I=1 TO 52 1230 R=FNR(52) 1240 IF NDECK$(R)="" THEN NDECK$(R)=DECK$(I) ELSE 1230 1250 NEXT I 1260 FOR I=1 TO 52 1270 DECK$(I)=NDECK$(I) 1280 NEXT I 1290 RETURN 1300 REM Display a card (C$) 1310 IF C$=DOWN$ THEN 1350 1320 IF C$=" " THEN 1350 1330 S=ASC(RIGHT$(C$,1))-2 1340 COLOR CLR(S,1),CLR(S,2) 1350 PRINT C$;:COLOR 7,0:PRINT " "; 1360 RETURN 1500 REM Deal the game 1510 C=1 1520 FOR PLACE=1 TO 7 1530 FOR ROW=1 TO 7 1535 IF ROW<PLACE THEN ROW$(ROW,PLACE,1)=" ":ROW$(ROW,PLACE,2)=" ":GOTO 1570 1540 ROW$(ROW,PLACE,1)=DECK$(C) 1550 C=C+1 1560 IF ROW=PLACE THEN ROW$(ROW,PLACE,2)=ROW$(ROW,PLACE,1) ELSE ROW$(ROW,PLACE,2)=DOWN$ 1570 NEXT ROW,PLACE 1580 CLS 1590 L=10:LOCATE 1,5:PRINT "Aces:" 1600 REM FOR ACE=1 TO 4 1610 REM LOCATE 1,L:COLOR 0,7:PRINT " ";SUIT$(ACE);:COLOR 7,0 1620 REM L=L+10 1630 REM NEXT ACE 1640 LOCATE 4,1 1645 PRINT " 1 2 3 4 5 6 7" 1650 FOR PLACE=1 TO 7 1660 FOR ROW=1 TO 7 1661 C$=ROW$(ROW,PLACE,2) 1665 C$=ROW$(ROW,PLACE,2) 1670 GOSUB 1300 1680 NEXT ROW:PRINT:NEXT PLACE 1690 RETURN 1700 REM Prepare to play 1710 FOR I=1 TO 24 1715 J=I+28 1720 NDECK$(I)=DECK$(J) 1730 NEXT I 1740 FOR I=25 TO 52 1750 NDECK$(I)="" 1760 NEXT I 1770 NDECK=24 1780 RETURN 1800 REM Show Deck 1810 LL=3 1815 LOCATE 3,50:PRINT "Cards left in deck:"; 1817 IF NDECK=0 THEN 1890 1820 FOR I=1 TO NDECK STEP 3 1830 LL=LL+1:LOCATE LL,50 1840 FOR J=0 TO 2 1845 IF I+J>NDECK THEN 1870 1850 C$=NDECK$(I+J) 1860 GOSUB 1300 1870 NEXT J:PRINT " ";:NEXT I 1880 RETURN 1890 LOCATE 4,50:PRINT "None. "; 1895 FOR I=2 TO 3:LOCATE LL+I,50:PRINT " ";:NEXT 1899 RETURN 1900 REM show cards 1910 LL=4:COUNT=0 1920 FOR PLACE=1 TO 19 1925 LL=LL+1:LOCATE LL,1 1930 FOR ROW=1 TO 7 1935 C$=ROW$(ROW,PLACE,2) 1940 IF C$=DOWN$ THEN C$=ROW$(ROW,PLACE,1):COUNT=COUNT+1 1950 GOSUB 1300 1960 NEXT ROW 1965 IF COUNT=0 THEN PLACE=20 1970 LOCATE LL,1:COUNT=0 1980 NEXT PLACE 1990 RETURN 2000 REM Check if above$ can go on below$ 2010 IN$=ABOVE$:GOSUB 3000:ANUM=NUM:ASUIT=SUIT 2020 IN$=BELOW$:GOSUB 3000:BNUM=NUM:BSUIT=SUIT 2030 OK$="YES" 2040 IF ANUM+1<>BNUM THEN OK$="NO" 2050 IF ASUIT<=2 AND BSUIT<=2 THEN OK$="NO" 2060 IF ASUIT>=3 AND BSUIT>=3 THEN OK$="NO" 2070 RETURN 2200 REM Repack Deck 2205 IF NDECK=1 THEN TOP=0:NDECK=0:RETURN 2210 FOR I=TOP+1 TO NDECK 2220 NDECK$(I-1)=NDECK$(I) 2230 NEXT I 2240 NDECK=NDECK-1 2250 TOP=TOP-1 2260 IF TOP<1 THEN TOP=3 2280 IF TOP>NDECK THEN TOP=NDECK 2290 RETURN 2300 REM Play ABOVE$ to aces 2310 IN$=ABOVE$:GOSUB 3000:ANUM=NUM:ASUIT=SUIT 2315 IN$=ACES$(ASUIT):IF IN$=" " THEN BNUM=0:GOTO 2330 2320 GOSUB 3000:BNUM=NUM 2330 IF ANUM=BNUM+1 THEN OK$="YES" ELSE OK$="NO":RETURN 2340 ACES$(ASUIT)=ABOVE$ 2350 LOCATE 1,ASUIT*10:C$=ABOVE$ 2360 GOSUB 1300 2365 SCORE=SCORE+1:LOCATE 1,50:PRINT "Score";SCORE 2370 RETURN 3000 REM change in$ to num and suit 3005 IF A$=" " THEN NUM=0:SUIT=0:RETURN 3010 A$=LEFT$(IN$,2) 3020 IF A$=" A" THEN A$=" 1" 3030 IF A$=" J" THEN A$="11" 3040 IF A$=" Q" THEN A$="12" 3050 IF A$=" K" THEN A$="13" 3060 NUM=VAL(A$) 3070 SUIT=ASC(RIGHT$(IN$,1))-2 3080 RETURN 3100 REM Redraw a row 3110 R=((ROW-1)*7)+1 3130 FOR PLACE=1 TO 19 3140 IF ROW$(ROW,PLACE,1)=" " THEN PLACE=20:GOTO 3180 3150 LOCATE 4+PLACE,R 3160 C$=ROW$(ROW,PLACE,2) 3170 GOSUB 1300 3180 NEXT PLACE 3190 RETURN 3200 REM Copy part of a row 3205 FP=FROMPLACE:TP=TOPLACE 3207 IF TP=1 AND LEFT$(ROW$(FROMROW,FROMPLACE,2),2)=" K" THEN 3220 3210 TP=TP+1 3220 ROW$(TOROW,TP,1)=ROW$(FROMROW,FP,1) 3225 ROW$(TOROW,TP,2)=ROW$(FROMROW,FP,2) 3230 REM ROW$(FROMROW,FP,1)=" " 3235 ROW$(FROMROW,FP,2)=" " 3240 FP=FP+1 3250 IF ROW$(FROMROW,FP,2)<>" " THEN 3210 3260 IF FROMPLACE>1 THEN 3300 3270 ROW$(FROMROW,FP,1)=" " 3280 ROW$(FROMROW,1,2)=" " 3290 RETURN 3300 ROW$(FROMROW,FROMPLACE-1,2)=ROW$(FROMROW,FROMPLACE-1,1) 3310 RETURN 3400 REM Evaluate game performance 3405 LOCATE 19,1:PRINT "You placed";SCORE;"cards on the Aces piles" 3410 SC=INT(SCORE/10)+1 3415 IF SCORE=52 THEN SC=7 3420 IF SCORE=0 THEN GOSUB 3520:RETURN 3430 ON SC GOSUB 3450,3460, 3470, 3480, 3490, 3500, 3510 3440 RETURN 'score 0-9 10-19 20-29 30-39 40-49 50+ 3450 PRINT "Too bad, better try again!":RETURN 3460 PRINT "Not too bad, still a lot of room for improvement":RETURN 3470 PRINT "Pretty good, keep trying.":RETURN 3480 PRINT "Good job. Keep up the good work!":RETURN 3490 PRINT "Very good. Now you have the idea!":RETURN 3500 PRINT "Almost got it. Bad break!":RETURN 3510 PRINT "YOU DID IT!! Congratulations!":RETURN 3520 PRINT "Oops! You must have had a bad shuffle!":RETURN 5000 REM Instructions 5010 cls:PRINT "Klondike Solitaire" 5020 PRINT 5030 PRINT "This program plays a solitaire game. A deck of 52 cards is" 5040 PRINT "used and 28 cards are dealt into 7 rows (piles). The first" 5050 PRINT "row at the left has one card, the second two, and so on, up" 5060 PRINT "to seven in the last row. The last card of each row is face" 5070 PRINT "up and all the rest are face down. On each row you may" 5080 PRINT "build in descending sequence: red on black, such as the ten" 5090 PRINT "of hearts on the jack of clubs or spades.":PRINT 5100 PRINT "You can move the face up cards in a row as a unit. The top" 5110 PRINT "card being moved must fit in sequence and color with the" 5120 PRINT "card being moved under in the other row. When you uncover a" 5130 PRINT "face-down card on a row, it will be turned up.":PRINT 5140 PRINT "You are always entitled to have 7 rows, and if one is" 5150 PRINT "entirely open you may put a king in the space. Whenever you" 5160 PRINT "free an ace, move it too the ace foundations. On the aces" 5170 PRINT "you may build up in suit and sequence and then to win the" 5180 PRINT "game, you have to build each suit up to a king. A card must" 5190 PRINT "be the top card of a row to be played from, to the rows onto" 5200 PRINT "the ace foundations. Once played on the ace foundations, a" 5210 PRINT "card can NOT be removed to help elsewhere." 5220 PRINT " ** Press any key to continue **"; 5230 IF INKEY$="" THEN 5230 ELSE CLS 5240 PRINT "The remaining 24 cards in the deck are used as the stock." 5250 PRINT "Every third card may be turned up and the deck may be gone" 5260 PRINT "through any number of times. The top card is available for" 5270 PRINT "play to any row or the ace foundations. When the top card" 5280 PRINT "is played, the next card will then be available.":PRINT 5290 PRINT "You win if you can build all 4 ace foundations up to kings." 5300 PRINT "You lose when you can not make any further plays from the" 5310 PRINT "deck, or rows.":PRINT 5320 PRINT "Plays are controlled by keyboard commands as follows:":PRINT 5330 PRINT "D = Play top card of the Deck to aces (A) or row (#1-7)." 5340 PRINT " Answer 'A' or row number 1-7 to next question to" 5350 PRINT " indicate where the card is to be moved." 5360 PRINT "C = Get next Card in the deck and wait for next play command." 5370 PRINT "Q = Quit game and turn over all face-down cards." 5380 PRINT "#1-7 = Play cards from row# to Aces (A) or another row (#1-7)" 5390 PRINT 5400 PRINT "An error message will be displayed if an invalid response is" 5410 PRINT "given to any question or any invalid plays attempted." 5420 PRINT:PRINT " ** Press any key to continue **"; 5430 IF INKEY$="" THEN 5430 ELSE CLS:RETURN 10000 REM Shift A$ to upper case 10020 L=LEN(A$) 'get length of a$ 10030 FOR I=1 TO L 'look at each char 10040 TEST=ASC(MID$(A$,I,1)) 'get acsii value 10050 IF TEST<97 OR TEST>122 THEN 10080 'skip if not lower case 10060 TEST=TEST-32 'bump down to upper case 10070 MID$(A$,I,1)=CHR$(TEST) 'insert upper case back 10080 NEXT I 'move on to next char 10090 RETURN